home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d4 / check6.arc / GRAPHIX.SYS < prev    next >
Encoding:
Text File  |  1988-06-26  |  10.8 KB  |  370 lines
  1. (***********************************************************)
  2. (*                                                         *)
  3. (*                TURBO GRAPHIX version 1.03A              *)
  4. (*                                                         *)
  5. (*      Graphics module for IBM Color/Graphics Adapter     *)
  6. (*                  Module version  1.01A                  *)
  7. (*                                                         *)
  8. (*                  Copyright (C) 1985 by                  *)
  9. (*                  BORLAND International                  *)
  10. (*                                                         *)
  11. (***********************************************************)
  12.  
  13. const XMaxGlb=79;                   { Number of BYTES -1 in one screen line }
  14.       XScreenMaxGlb=639;           { Number of PIXELS -1 in one screen line }
  15.       YMaxGlb=199;                       { Number of lines -1 on the screen }
  16.       IVStepGlb=2;                              { Initial value of VStepGlb }
  17.       ScreenSizeGlb=8191;            { Total size in integers of the screen }
  18.       HardwareGrafBase=$B800;     { Segment location of the hardware screen }
  19.       FontLoaded:boolean=false;       { Flag: has the font been loaded yet? }
  20.       MinForeground:integer=0;          { Lowest allowable foreground color }
  21.       MaxForeground:integer=15;        { Highest allowable foreground color }
  22.       MinBackground:integer=0;          { Lowest allowable background color }
  23.       MaxBackground:integer=0;         { Highest allowable background color }
  24.       AspectFactor=0.44;                   { Aspect ratio for a true circle }
  25.       SaveStateGlb:integer=10;
  26.       ForegroundColorGlb:integer=15;
  27.  
  28. type  ScreenType=array [0..ScreenSizeGlb] of integer;
  29.       ScreenPointer=^ScreenType;
  30.       FontChar=array [0..7] of byte;
  31.       IBMFont=array [0..255] of FontChar;
  32.       WindowStackRecord=record
  33.                           W:WindowType;
  34.                           Contents:ScreenPointer;
  35.                         end;
  36.       stacks=array [1..MaxWindowsGlb] of WindowStackRecord;
  37.  
  38. var   ScreenGlb:ScreenPointer;
  39.       ConOutPtrSave:integer;
  40.       Font:IBMFont;
  41.       Stack:Stacks;
  42.       DisplayType:(IBMPCjr,IBMCGA,IBMEGA,NoDisplay);
  43.  
  44. procedure error(ErrProc,ErrCode:integer); forward; { Code in KERNEL.SYS }
  45.  
  46. function HardwarePresent: boolean;
  47.   var i,EquipFlag:integer;
  48.       Info,EGASwitch:byte;
  49.       HP:boolean;
  50.       regs:record case integer of
  51.              1:(ax,bx,cx,dx,bp,si,di,ds,es,flgs:integer);
  52.              2:(al,ah,bl,bh,cl,ch,dl,dh:byte);
  53.            end;
  54.   begin
  55.     HP:=false;
  56.     DisplayType:=NoDisplay;
  57.     with regs do
  58.      begin
  59.       intr($11,regs);
  60.       EquipFlag:=AX;
  61.       ah:=$12;
  62.       bl:=$10;
  63.       intr($10,regs);
  64.       EGASwitch:=CL;
  65.       Info:=BH;
  66.      end;
  67.     if mem[$F000:$FFFE]=$FD then  { PCjr }
  68.      begin
  69.       MinForeground:=0;           { Actually only 0 and 15 are valid }
  70.       MaxForeground:=15;
  71.       MinBackground:=0;
  72.       MaxBackground:=15;
  73.       DisplayType:=IBMPCjr;
  74.       HP:=true;
  75.      end
  76.     else if ((EquipFlag and 52) in [0,16,32]) and (Info=0) then
  77.      begin                        { EGA present, active, and in color }
  78.       MinForeground:=0;
  79.       MaxForeground:=15;
  80.       MinBackground:=0;
  81.       MaxBackground:=15;
  82.       DisplayType:=IBMEGA;
  83.       HP:=true;
  84.      end;
  85.     if not HP then
  86.       if ((EquipFlag and 48) in [16,32] { CGA }) or
  87.          (((EquipFlag and 52)=4 { EGA but not active }) and
  88.           (EGASwitch in [4,5,10,11]) { EGA is mono, CGA for color }) then
  89.        begin
  90.         MinForeground:=0;
  91.         MaxForeground:=15;
  92.         MinBackground:=0;
  93.         MaxBackground:=0;
  94.         DisplayType:=IBMCGA;
  95.         HP:=true;
  96.        end;
  97.     HardwarePresent:=HP;
  98.   end;
  99.  
  100. procedure AllocateRAMScreen;
  101.   var test:^integer;
  102.   begin
  103.     new(ScreenGlb);
  104.     while ofs(ScreenGlb^)<>0 do   { Make absolutely certain that ScreenGlb }
  105.      begin                        {  is on a segment (16 byte) boundary! }
  106.       dispose(ScreenGlb);
  107.       new(test);
  108.       new(ScreenGlb);
  109.      end;
  110.   end;
  111.  
  112. function BaseAddress(Y: integer): integer;
  113.   begin
  114.     BaseAddress:=(Y and 1) shl 13 + (Y and -2) shl 5 + (Y and -2) shl 3;
  115.   end;
  116.  
  117. procedure LeaveGraphic;
  118.   var regs:record case integer of
  119.              1:(ax,bx,cx,dx,bp,si,di,ds,es,flgs: integer);
  120.              2:(al,ah,bl,bh,cl,ch,dl,dh: byte);
  121.            end;
  122.   begin
  123.     regs.ax:=SaveStateGlb;
  124.     intr($10,regs);
  125.     if GrafModeGlb then ConOutPtr:=ConOutPtrSave;
  126.     GrafModeGlb:=false;
  127.   End;
  128.  
  129. procedure DC(C: byte);
  130.   begin
  131.     inline($8A/$9E/ C /$B7/$00/$D1/$E3/$D1/$E3/$D1/$E3/$81/$C3/ Font /$8A/$16/
  132.            XTextGlb /$FE/$CA/$B6/$00/$8B/$FA/$8A/$16/ YTextGlb /$4A/$D1/$E2/
  133.            $D1/$E2/$D1/$E2/$A1/ GrafBase /$8E/$C0/$B5/$08/$B1/$0D/$8B/$C2/$25/
  134.            $01/$00/$D3/$E0/$8B/$F0/$8B/$C2/$25/$FE/$FF/$B1/$03/$D3/$E0/$03/
  135.            $F0/$FE/$C9/$D3/$E0/$03/$F0/$03/$F7/$8A/$07/$26/$88/$04/$43/$42/
  136.            $FE/$CD/$75/$D7);
  137.   end;
  138.  
  139. procedure DisplayChar(C: byte);
  140.   begin
  141.     if C=8 then
  142.      begin
  143.       if XTextGlb>1 then XTextGlb:=XTextGlb-1;
  144.      end
  145.     else if C=10 then
  146.      begin
  147.       if YTextGlb<25 then YTextGlb:=YTextGlb+1;
  148.      end
  149.     else if C=13 then XTextGlb:=1
  150.     else
  151.      begin
  152.       DC(C);
  153.       if XTextGlb<80 then XTextGlb:=XTextGlb+1;
  154.      end;
  155.   end;
  156.  
  157. procedure SetIBMPalette(PaletteNumber,Color:integer);
  158.   var regs:record case integer of
  159.              1:(ax,bx,cx,dx,bp,si,di,ds,es,flgs: integer);
  160.              2:(al,ah,bl,bh,cl,ch,dl,dh: byte);
  161.            end;
  162.   begin
  163.     with regs do
  164.      begin
  165.       if PaletteNumber<>2 then
  166.        begin
  167.         ah:=$0B;
  168.         bl:=Color;
  169.         bh:=PaletteNumber;
  170.        end
  171.       else
  172.        begin
  173.         ax:=$1000;
  174.         bl:=1;
  175.         bh:=Color;
  176.        end;
  177.       intr($10,regs);
  178.      end;
  179.   end;
  180.  
  181. procedure SetForegroundColor(Color: Integer);
  182.   begin
  183.     case DisplayType of
  184.       IBMPCjr: SetIBMPalette(1,1-(Color and 1));
  185.       IBMCGA:  SetIBMPalette(0,Color);
  186.       IBMEGA:  SetIBMPalette(2,Color);
  187.      end;
  188.     ForegroundColorGlb:=Color;
  189.   end;
  190.  
  191. procedure SetBackgroundColor(Color: Integer);
  192.   begin
  193.     case DisplayType of
  194.       IBMPCjr,
  195.       IBMEGA:  SetIBMPalette(0,Color);
  196.      end;
  197.     if DisplayType=IBMEGA then SetIBMPalette(2,ForegroundColorGlb);
  198.   end;
  199.  
  200. procedure ClearScreen;
  201.   begin
  202.     fillchar(mem[GrafBase:0000],(ScreenSizeGlb+1) Shl 1,0);
  203.   end;
  204.  
  205. procedure EnterGraphic;
  206.   type reg=record case integer of
  207.              1:(ax,bx,cx,dx,bp,si,di,ds,es,flgs: integer);
  208.              2:(al,ah,bl,bh,cl,ch,dl,dh: byte);
  209.            end;
  210.   var regs:reg;
  211.       FontFile: file of IBMFont;
  212.   begin
  213.     if not FontLoaded then
  214.      begin
  215.       Assign(FontFile,'8x8.FON');
  216.       {$I-} Reset(FontFile); {$I+}
  217.       if IOResult=0 then
  218.        begin
  219.         Read(FontFile,Font);
  220.         Close(FontFile);
  221.        end
  222.       else FillChar(Font,SizeOf(Font),0);
  223.       FontLoaded:=true;
  224.      end;
  225.     regs.ax:=$0f00;
  226.     intr($10,regs);
  227.     if (regs.al<4) or (SaveStateGlb=10) then SaveStateGlb:=regs.al;
  228.     regs.ax:=$0006;
  229.     intr($10,regs);
  230.     SetForegroundColor(MaxForeground);
  231.     if not GrafModeGlb then ConOutPtrSave:=ConOutPtr;
  232.     ConOutPtr:=ofs(DisplayChar);
  233.     GrafModeGlb:=true;
  234.   end;
  235.  
  236. procedure DP(X,Y: integer);
  237.   begin
  238.     inline($B8/$01/$00/$8B/$5E/$04/$21/$D8/$B1/$0D/$D3/$E0/$81/$E3/$FE/$FF/
  239.            $B1/$03/$D3/$E3/$01/$D8/$B1/$02/$D3/$E3/$01/$D8/$8B/$5E/$06/$89/
  240.            $DA/$B1/$03/$D3/$EB/$01/$C3/$88/$D1/$80/$E1/$07/$B2/$80/$D2/$EA/
  241.            $8E/$06/ GrafBase /$80/$3E/ ColorGlb /$FF/$75/$05/$26/$08/$17/$EB/
  242.            $05/$F6/$D2/$26/$20/$17);
  243.   end;
  244.  
  245. function PD(x,y:integer):boolean;
  246.   begin
  247.     PD:=(ColorGlb=0) xor (mem[GrafBase:BaseAddress(y) + x shr 3]
  248.                           and (128 shr (x and 7)) <> 0);
  249.   end;
  250.  
  251. procedure SetBackground8(Background:BackgroundArray);
  252.   var i:integer;
  253.   begin
  254.     for i:=Y1RefGlb to Y2RefGlb do
  255.       FillChar(mem[GrafBase:BaseAddress(i)+X1RefGlb],X2RefGlb-X1RefGlb+1,
  256.                Background[i and 7]);
  257.   end;
  258.  
  259. procedure SetBackground(byt:byte);
  260.   var bk:BackgroundArray;
  261.   begin
  262.     fillchar(bk,8,byt);
  263.     SetBackground8(bk);
  264.   end;
  265.  
  266. procedure DrawStraight(x1,x2,y:integer);  { Draw a horizontal line from
  267.                                             x1,y to x2,y }
  268.   var i,x:integer;
  269.       DirectModeLoc:boolean;
  270.   begin
  271.     if (not ((x1<0) or (x1>XMaxGlb shl 3+7)) and not ((x2<0) or
  272.        (x2>XMaxGlb shl 3+7)) and ((y>=0) and (y<=YMaxGlb))) then
  273.      begin
  274.       DirectModeLoc:=DirectModeGlb;
  275.       DirectModeGlb:=true;
  276.       if x1>x2 then
  277.        begin
  278.         x:=x1;
  279.         x1:=x2;
  280.         x2:=x;
  281.        end;
  282.       if x2-x1<16 then
  283.         for x:=x1 to x2 do dp(x,y)
  284.       else
  285.        begin
  286.         x1:=x1+8;
  287.         for i:=(x1-8) to (x1 and -8) do dp(i,y);
  288.         for i:=(x2 and -8) to x2 do dp(i,y);
  289.         FillChar(Mem[GrafBase:BaseAddress(Y)+(X1 Shr 3)],
  290.                  (X2 Shr 3)-(X1 Shr 3),ColorGlb);
  291.        end;
  292.       DirectModeGlb:=DirectModeLoc;
  293.      end
  294.   end;
  295.  
  296. procedure SaveScreen(FileName:wrkstring);
  297.   type PicFile=file of ScreenType;
  298.   var picture:ScreenPointer;
  299.       PictureFile:PicFile;
  300.       ioerr:boolean;
  301.   procedure IOCheck;
  302.   begin
  303.     ioerr:=IOResult<>0;
  304.     if ioerr then Error(27,5);
  305.   end;
  306.  
  307.   begin
  308.     ioerr:=false;
  309.     picture:=ptr(GrafBase,0);
  310.     assign(PictureFile,FileName);
  311.     {$I-} rewrite(PictureFile); {$I+}
  312.     IOCheck;
  313.     if not ioerr then
  314.      begin
  315.       {$I-} write(PictureFile,picture^); {$I+}
  316.       IOCheck;
  317.      end;
  318.     if not ioerr then
  319.      begin
  320.       {$I-} close(PictureFile); {$I+}
  321.       IOCheck;
  322.      end;
  323.   end;
  324.  
  325. procedure LoadScreen(FileName:wrkstring);
  326.   type PicFile=file of ScreenType;
  327.   var picture:ScreenPointer;
  328.       PictureFile:PicFile;
  329.   begin
  330.     picture:=ptr(GrafBase,0);
  331.     assign(PictureFile,FileName);
  332.     {$I-} reset(PictureFile); {$I+}
  333.     if IOResult<>0 then Error(11,5)
  334.     else
  335.      begin
  336.       read(PictureFile,picture^);
  337.       close(PictureFile);
  338.      end;
  339.   end;
  340.  
  341. procedure SwapScreen;
  342.   const SS=$2000; { ScreenSizeGlb+1 }
  343.   var g:integer;
  344.   begin
  345.     if RamScreenGlb then
  346.      begin
  347.       g:=seg(ScreenGlb^);
  348.       Inline($8B/$86/ g /$8E/$C0/$1E/$B8/ HardwareGrafBase /$8E/$D8/$B9/
  349.              SS /$31/$DB/$8B/$07/$26/$87/$07/$89/$07/$43/$43/$E2/$F5/$1F);
  350.      end;
  351.   end;
  352.  
  353. procedure CopyScreen;
  354.   var ToBase:integer;
  355.   begin
  356.     if RamScreenGlb then
  357.      begin
  358.       if GrafBase=HardwareGrafBase then ToBase:=seg(ScreenGlb^)
  359.       else ToBase:=HardwareGrafBase;
  360.       move(mem[GrafBase:0000],mem[ToBase:0000],(ScreenSizeGlb+1) Shl 1);
  361.      end;
  362.   end;
  363.  
  364. procedure InvertScreen;
  365.   const SS=$2000; { ScreenSizeGlb+1 }
  366.   begin
  367.     Inline($1E/$A1/ GrafBase /$8E/$D8/$B9/ SS /$31/$DB/$F7/$17/$43/$43/$E2/
  368.            $FA/$1F);
  369.   end;
  370.